Amiga Format CD 38/Amiga Format CD38 (1999-03-15)(Future Publishing)(GB)(Track 1 of 3)[!][issue 1999-04].iso/-seriously_amiga-/programming/basic/landscaper/landscaper.bb2

Text File | 1999-01-25 | 41KB | 1,496 lines

; *****************************************
; *                                       *
; *     Landscaping by David McMinn       *
; *  (not a gardening program, idiot)     *
; *                                       *
; *  Run this or be slapped in the face   *
; *  (only kidding but run it cos you`ll  *
; *            like it)                   *
; *                                       *
; *****************************************
; *                                       *
; * Program name: Landmakerv2_2.bb2       *
; * Created     : 21/9/95                 *
; * Last Saved  : 5/12/95                 *
; *                                       *
; *****************************************

; *** Useful functions (not for map drawing) ***

Statement centre{a$,ww}
  x=(ww-12-Len(a$)*8)/2
  WLocate x,WCursY
  NPrint a$
End Statement

Statement wprint{a$}
  WLocate 5,2
  InnerCls
  For i=1 To 3
    Redraw 0,i
  Next
  Print a$
End Statement


; *** Set up startup stuff ***

WBStartup:NoCli
CloseEd

If ExecVersion<37 Then End

WbToScreen 0
WBenchToFront_

*scr._Screen = Peek.l(Addr Screen(0))

AddIDCMP $10
RRandomize Timer

SetErr
  End
End SetErr

;*** Set all startup variables ***

  wbw.l=*scr\Width
  wbh.l=*scr\Height

  dsize.w=10
  dxscale.q=8
  dyscale.q=4
  dzscale.q=1
  dfaults.l=100
  ddelta.q=3

  size.w=10
  xscale.q=8
  yscale.q=4
  zscale.q=1
  circular=1
  linear=0
  faults.l=100
  delta.q=3
  scrmd.w=1
  clrs.w=1

  osize.w=size
  oxscale.q=xscale
  oyscale.q=yscale
  ozscale.q=zscale
  ocircular=circular
  olinear=linear
  ofaults.l=faults
  odelta.q=delta
  oscrmd.w=scrmd
  oclrs.w=clrs

  map=0
  iff=0
  aga=CheckAGA

  *smr.ScreenModeRequester = 0
  idhandle.l = 0
  DEFTYPE.ScreenModeRequester mode, newmode
  DEFTYPE.NameInfo ni
  mode\sm_DisplayID = 0,320,200,4
  idhandle=FindDisplayInfo_(mode\sm_DisplayID)
  GetDisplayInfoData_ idhandle,&ni,SizeOf.NameInfo,$80003000,0

  MaxLen pa$=192
  MaxLen fi$=192

  NEWTYPE.tri
    x1.w
    y1.w
    x2.w
    y2.w
    x3.w
    y3.w
  End NEWTYPE

  DEFTYPE.tri stuff

  NEWTYPE.pal
    r.w
    g.w
    b.w
  End NEWTYPE

  DEFTYPE.w rr,gg,bb
  Dim dcolours.ColorSpec(33),colours.ColorSpec(33)
  Restore colourvalues
  For i=0 To 31
    Read rr,gg,bb
    dcolours(i)\ColorIndex=i,rr,gg,bb
    colours(i)\ColorIndex=i,rr,gg,bb
  Next
  dcolours(32)\ColorIndex=-1
  colours(32)\ColorIndex=-1

  Dim s.b(2),x.b(2),y.b(2),height.q(4)

; *** Set up menus ***

MenuTitle 0,0,"Project"
MenuItem 0,0,0,0,"Load map      ","L"
MenuItem 0,0,0,1,"Save       "+Chr$(187)
SubItem 0,0,0,1,0,"Save IFF      ","S"
SubItem 0,0,0,1,1,"Save map      ","M"
MenuItem 0,0,0,2,"About         ","A"
MenuItem 0,0,0,3,"Quit          ","Q"
MenuTitle 0,1,"Landscape"
MenuItem 0,0,1,0,"Options       ","?"
MenuItem 0,0,1,1,"Generate      ","G"
MenuItem 0,0,1,2,"Show map      "


; *** Set up GUI gadgets for main window ***

GTButton 0,1,18,23,84,12,"Generate",$10
GTButton 0,2,123,23,52,12,"Stop",$10|$40|$80
GTButton 0,3,200,23,76,12,"Options",$10


; *** Set up GUI gadgets for options window ***

GTInteger 1,1,100,5,64,14,"Faults",$1,0
GTInteger 1,2,100,19,64,14,"Size",$1,0
GTInteger 1,3,100,33,64,14,"X scale",$1,0
GTInteger 1,4,100,47,64,14,"Y scale",$1,0
GTInteger 1,5,100,61,64,14,"Z scale",$1,0
GTInteger 1,6,100,75,64,14,"Delta",$1,0
GTCheckBox 1,7,100,89,12,14,"Circular",$1
GTCheckBox 1,8,100,103,12,14,"Linear",$1
GTText  1,9,100,117,198,14,"Screen Mode",#PLACETEXT_LEFT,""
GTNumber 1,10,100,131,32,14,"Depth",#PLACETEXT_LEFT,mode\sm_DisplayDepth
GTButton 1,11,26,150,82,14,"Default",$30
GTButton 1,12,134,150,82,14,"Help me",$30
GTButton 1,13,74,173,68,14,"OK",$10
GTButton 1,14,212,173,68,14,"CANCEL",$10
GTButton 1,15,242,150,82,14,"Palette",$30
GTButton 1,16,300,117,30,14,"(?)",#PLACETEXT_IN

; *** Show user interface and other muck ***

ww.w = *scr\WBorLeft+300+*scr\WBorRight
wh.w = *scr\WBorTop+*scr\Font\ta_YSize+1+50+*scr\WBorBottom
Window 0,(wbw-ww)/2,(wbh-wh)/2,ww,wh,$2|$4|$8|$1000,"Landscaper V1.12 by Dave McMinn",-1,-1

SetMenu 0

AttachGTList 0,0

exit=0
While exit=0
  .mainloop:
  ev.l=WaitEvent
  Select ev
    Case $200:exit=1;                   Has close gadget been pressed
    Case $100;                          Has a menu e_vent occurred
      Select MenuHit
        Case 0;                         Something from project menu
          Select ItemHit
            Case 0:Gosub loadmap;       Load map
            Case 1
              Select SubHit
                Case 0:Gosub saveiff;   Save IFF
                Case 1:Gosub savemap;   Save map
              End Select
            Case 2:Gosub info;          M-Hinfo
            Case 3:exit=1;              Quit
          End Select
        Case 1;                         Something from Landscape menu
          Select ItemHit
            Case 0:Gosub options;       Options is chosen
            Case 1:Gosub gennew;        Generate new map
            Case 2:Gosub showold;       Show old map
          End Select
      End Select
    Case $40;                           a gadget E_vent
      Select GadgetHit
        Case 1          ;               Generate has been picked
            If mode\sm_DisplayID=0
                body$="If you want to see the picture you need"+Chr$(10)
                body$+"to pick a screenmode from the options."+Chr$(10)
                body$+"What do you want to do?"
                dummy=EasyRequest("Information",body$,"Options|Continue")
                If dummy=1 Then Gosub options
            End If
            Gosub gennew
        Case 3:Gosub options;           Options has been picked
      End Select
  End Select
Wend
End

.loadmap:
  f$=ASLFileRequest$("Load a map file",pa$,fi$)
  If f$
    wprint{"Loading map file..."}
    If ReadFile(0,f$)
      FileInput 0
      filetype$=Inkey$(6)
      If filetype$="McMinn"
        osize=Cvi(Inkey$(2))
        size=osize
        xscale=Cvq(Inkey$(4))
        yscale=Cvq(Inkey$(4))
        zscale=Cvq(Inkey$(4))
        faults=Cvl(Inkey$(4))
        delta=Cvq(Inkey$(4))
        Dim land.q(size+1,size+1)
        For i=0 To size
          For j=0 To size
            land(i,j)=Cvq(Inkey$(4))
          Next
        Next
        map=1
        wprint{""}
      Else
        wprint{"Not a Landscaper file."}
      End If
      CloseFile 0
      DefaultInput
    Else
      wprint{"Could not load data file."}
    End If
  End If
  Return

.saveiff:
  If iff=1
    f$=ASLFileRequest$("Save IFF image",pa$,fi$)
    If f$
      ovr=1
      If Exists(f$)
        ovr=EasyRequest("Landscape Request","Do you wish to overwrite|"+Chr$(10)+f$," Yes | No ")
      End If
      If ovr=1
        wprint{"Saving IFF image ..."}
        SaveBitmap 0,f$,0
        wprint{""}
      End If
    End If
  Else
    wprint{"No IFF in memory."}
  End If
  Return

.savemap:
  If map=1
    f$=ASLFileRequest$("Save a map file",pa$,fi$)
    If f$
      ovr=1
      If Exists(f$)
        ovr=EasyRequest("Landscape Request","Do you wish to overwrite"+Chr$(10)+f$," Yes | No ")
      End If
      If ovr=1
        wprint{"Saving map file ..."}
        If WriteFile(0,f$)
          FileOutput 0
          Print "McMinn"
          Print Mki$(osize)
          Print Mkq$(oxscale)
          Print Mkq$(oyscale)
          Print Mkq$(ozscale)
          Print Mkl$(ofaults)
          Print Mkq$(odelta)
          For i=0 To osize
            For j=0 To osize
              Print Mkq$(land(i,j))
            Next
          Next
          CloseFile 0
          DefaultOutput
        Else
          wprint{"Could not save data file."}
        End If
      End If
    End If
    wprint{""}
  Else
    wprint{"No map in memory."}
  End If
  Return

.info:
  Restore infotext
  about$=""
  For i=0 To 13
    Read text$
    about$=about$+text$+Chr$(10)
  Next
;  about$=about$+Chr$(10)
;  about$=about$+Str$(?????)+" bytes Chip free"+Chr$(10)
;  about$=about$+Str$(?????)+" bytes Fast free"+Chr$(10)
  EasyRequest "About Landscaper",about$,"OK"
  Return

.gennew:
  GTDisable 0,1
  GTEnable 0,2
  GTDisable 0,3
  For i=1 To 3
    Redraw 0,i
  Next
  Dim land.q(size+1,size+1)
  Gosub init
  Gosub shift
  Gosub levels
  Gosub draw
  Return

.showold:
  If map=1
    GTDisable 0,1
    GTEnable 0,2
    GTDisable 0,3
    For i=1 To 3
      Redraw 0,i
    Next
    size=osize
    Gosub init
    Gosub levels
    Gosub draw
  Else
    WLocate 5,2
    InnerCls
    For i=1 To 3
      Redraw 0,i
    Next
    Print "No map in memory."
  End If
  Return

.options:
  Menus Off

  oww.w = *scr\WBorLeft+350+*scr\WBorRight
  owh.w = *scr\WBorTop+*scr\Font\ta_YSize+1+200+*scr\WBorBottom
  Window 1,(wbw-oww)/2,(wbh-owh)/2,oww,owh,$1000,"             Rendering Options",-1,-1

  smok.w = 0

  AttachGTList 1,1
  idhandle=FindDisplayInfo_(mode\sm_DisplayID)
  If GetDisplayInfoData_(idhandle,&ni,SizeOf.NameInfo,$80003000,0)
    GTSetString 1,9,Peek$(&ni\Name)
  Else
    GTSetString 1,9,""
  End If
  GTSetInteger 1,1,faults
  GTSetInteger 1,2,size
  GTSetInteger 1,3,xscale
  GTSetInteger 1,4,yscale
  GTSetInteger 1,5,zscale
  GTSetInteger 1,6,delta
  If circular=1
    GTToggle 1,7,On
  Else
    GTToggle 1,7,Off
  End If
  If linear=1
    GTToggle 1,8,On
  Else
    GTToggle 1,8,Off
  End If

  GTDisable 0,1:Redraw 0,1
  GTDisable 0,3:Redraw 0,3

  Redraw 1,7
  Redraw 1,8

  newmode\sm_DisplayID = mode\sm_DisplayID,mode\sm_DisplayWidth,mode\sm_DisplayHeight,mode\sm_DisplayDepth


  While exit=0
    ev=WaitEvent
    Select ev
      Case #IDCMP_CLOSEWINDOW
        exit=1
      Case #IDCMP_GADGETUP;            Gadget is released
        Select GadgetHit
;          Case 9:tmp1=EventCode;        Screenmode cycle
;          Case 10:tmp2=EventCode;       Colours cycle
          Case 11;                      Defaults button
            GTSetInteger 1,1,dfaults
            GTSetInteger 1,2,dsize
            GTSetInteger 1,3,dxscale
            GTSetInteger 1,4,dyscale
            GTSetInteger 1,5,dzscale
            GTSetInteger 1,6,ddelta
            GTToggle 1,7,On
            Redraw 1,7
            GTToggle 1,8,Off
            Redraw 1,8
          Case 12:Gosub helpme;         Help me! button
          Case 13;                      OK button
            faults=GTGetInteger(1,1)
            size=GTGetInteger(1,2)
            If size<2 Then size=2
            If size>160 Then size=160
            xscale=GTGetInteger(1,3)
            yscale=GTGetInteger(1,4)
            If yscale<0 Then yscale=0
            zscale=GTGetInteger(1,5)
            If zscale<0 Then zscale=0
            delta=GTGetInteger(1,6)
            circular=Abs(GTStatus(1,7))
            linear=Abs(GTStatus(1,8))
            mode\sm_DisplayID = newmode\sm_DisplayID,newmode\sm_DisplayWidth,newmode\sm_DisplayHeight,newmode\sm_DisplayDepth
            idhandle=FindDisplayInfo_(mode\sm_DisplayID)
            GetDisplayInfoData_ idhandle,&ni,SizeOf.NameInfo,$80003000,0
            exit=1
          Case 14:exit=1;               CANCEL button
          Case 15
            If newmode\sm_DisplayID=0
                opttemp$="In the interest of your sanity,"+Chr$(10)
                opttemp$+"please select a screenmode first,"+Chr$(10)
                opttemp$+"with the (?) gadget"
                dummy=EasyRequest("Warning!",opttemp$,"I will")
            Else
                Gosub alette;         Palette button
            End If
          Case 16:Gosub srequest

        End Select
    End Select
  Wend
  exit=0
  DetachGTList 1
  Free Window 1
  Use Window 0
  GTEnable 0,1:Redraw 0,1
  GTEnable 0,3:Redraw 0,3
  Menus On
  Return

srequest:
    Dim SMRtags.TagItem(18)
    SMRtags(0)\ti_Tag=#ASLSM_InitialLeftEdge,160     ;these are the position for the
    SMRtags(1)\ti_Tag=#ASLSM_InitialTopEdge,10       ;screenmode requester
    SMRtags(2)\ti_Tag=#ASLSM_InitialWidth,320
    SMRtags(3)\ti_Tag=#ASLSM_InitialHeight,200
    SMRtags(4)\ti_Tag=#ASLSM_InitialDisplayID,newmode\sm_DisplayID
    SMRtags(5)\ti_Tag=#ASLSM_InitialDisplayDepth,newmode\sm_DisplayDepth
    SMRtags(6)\ti_Tag=#ASLSM_InitialDisplayWidth,newmode\sm_DisplayWidth
    SMRtags(7)\ti_Tag=#ASLSM_InitialDisplayHeight,newmode\sm_DisplayHeight
    SMRtags(8)\ti_Tag=#ASLSM_InitialInfoOpened,0
    SMRtags(9)\ti_Tag=#ASLSM_DoDepth,1              ;0 for no depth selector
    SMRtags(10)\ti_Tag=#ASLSM_DoOverscanType,0       ;0 for no OverScan selector
    SMRtags(11)\ti_Tag=#ASLSM_DoWidth,1              ;0 for no width gadget
    SMRtags(12)\ti_Tag=#ASLSM_DoHeight,1             ;0 for no height gadget
    SMRtags(13)\ti_Tag=#ASLSM_MinHeight,200          ;minimum height allowed
    SMRtags(14)\ti_Tag=#ASLSM_MinWidth,320           ;minimum width allowed
    SMRtags(15)\ti_Tag=#ASLSM_MinDepth,4             ;minimum depth allowed
    SMRtags(16)\ti_Tag=#ASLSM_MaxDepth,5
    SMRtags(17)\ti_Tag=#TAG_END

    *smr=AllocAslRequest_(2,&SMRtags(0)\ti_Tag)
    smok=AslRequest_(*smr,&SMRtags(0)\ti_Tag)

    If smok<>0
        newmode\sm_DisplayID = *smr\sm_DisplayID,*smr\sm_DisplayWidth,*smr\sm_DisplayHeight,*smr\sm_DisplayDepth
        idhandle=FindDisplayInfo_(newmode\sm_DisplayID)
        GetDisplayInfoData_ idhandle,&ni,SizeOf.NameInfo,$80003000,0
        GTSetString 1,9,Peek$(&ni\Name)
        GTSetInteger 1,10,newmode\sm_DisplayDepth
    EndIf
    If *smr Then FreeAslRequest_ *smr
    Return

.helpme:
  Restore helptext
  about$=""
  For i=1 To 13
    Read text$
    about$=about$+text$+Chr$(10)
  Next
  EasyRequest "Landscaper Help",about$,"OK"
  Return

.alette:
    ; *** Set up GUI for palette changing window ***
    #tag=$80080000

    #gtsl_level=#tag+40
    #gtsl_maxlevellen=#tag+41
    #gtsl_levelformat=#tag+42
    #gtsl_levelplace=#tag+43

    lfor$="%2ld"

    current=1
    GTPalette 2,1,16,85,600,50,"",$8,newmode\sm_DisplayDepth

    GTTags #gtsl_levelformat,&lfor$,#gtsl_maxlevellen,4,#gtsl_levelplace,$2
    GTSlider 2,2,155,10,150,12,"Red",$81,0,15

    GTTags #gtsl_levelformat,&lfor$,#gtsl_maxlevellen,4,#gtsl_levelplace,$2
    GTSlider 2,3,155,24,150,12,"Green",$81,0,15

    GTTags #gtsl_levelformat,&lfor$,#gtsl_maxlevellen,4,#gtsl_levelplace,$2
    GTSlider 2,4,155,38,150,12,"Blue",$81,0,15

    GTButton 2,5,16,167,60,12,"Load",$10
    GTButton 2,6,80,167,60,12,"Save",$10

    GTButton 2,7,180,167,80,12,"Default",$10
    GTButton 2,8,264,167,80,12,"Spread",$10
    GTButton 2,9,348,167,80,12,"Copy",$10
    GTButton 2,10,432,167,80,12,"Exch.",$10

    GTButton 2,11,160,220,80,12,"OK",$10
    GTButton 2,12,400,220,80,12,"CANCEL",$10

    GTText 2,13,50,197,540,12,"Messages",$4," "


    ;Screen 1,13
    Dim SCRtags.TagItem(10)

    SCRtags(0)\ti_Tag=#SA_DisplayID,newmode\sm_DisplayID
    SCRtags(1)\ti_Tag=#SA_Depth,newmode\sm_DisplayDepth
    SCRtags(2)\ti_Tag=#SA_Width,640
    SCRtags(3)\ti_Tag=#SA_Height,400
    SCRtags(4)\ti_Tag=#SA_AutoScroll,-1
    SCRtags(5)\ti_Tag=#SA_Overscan,#OSCAN_TEXT
    SCRtags(6)\ti_Tag=#SA_Top,0
    SCRtags(7)\ti_Tag=#SA_Left,0
    SCRtags(8)\ti_Tag=#SA_ShowTitle,0
    SCRtags(9)\ti_Tag=#TAG_END

    If newmode\sm_DisplayWidth > 640
        SCRtags(2)\ti_Tag=#SA_Width,newmode\sm_DisplayWidth
    End If

    If newmode\sm_DisplayHeight > 400
        SCRtags(3)\ti_Tag=#SA_Height,newmode\sm_DisplayHeight
    End If

    If ScreenTags(1,"",&SCRtags(0))
        Use Palette 0
        blank$="                              "
        current=1

        Window 2,0,0,640,256,$1000,"Palette ...",-1,-1

        For i=0 To (1 LSL newmode\sm_DisplayDepth - 1)
            RGB i,colours(i)\_Red,colours(i)\_Green,colours(i)\_Blue
        Next

        AttachGTList 2,2

        GTBevelBox 2,355,21,80,40,40
        WBox 362,24,427,57,current
        GTSetAttrs 2,2,#gtsl_level,Red(current)
        GTSetAttrs 2,3,#gtsl_level,Green(current)
        GTSetAttrs 2,4,#gtsl_level,Blue(current)

        WLocate 16,75
        Print "Back  Sea Sand Lowest",SPACE$(16),"Land Shading",SPACE$(18),"Highest"
        If newmode\sm_DisplayDepth=5
            WLocate 24,145
            Print "Deepest       Water shades (32 colour only)         Shallowest   Not Used"
        End If


        exit=0
        While exit=0
            If ev.l<>$10;;              If previous Event was NOT a Mouse MOVE
                ev2.l=ev.l;               set previous event
            End If
            ev.l=WaitEvent
            Select ev
                Case $10
                    If ev2=$20;;            If previous Event was a button held down
                        Select GadgetHit;     i.e. slider was dragged
                            Case 2;             If its red thats changed
                                RGB current,EventCode,Green(current),Blue(current)

                            Case 3;             If its green thats changed
                                RGB current,Red(current),EventCode,Blue(current)

                            Case 4;             If its blue thats changed
                                RGB current,Red(current),Green(current),EventCode
                        End Select
                    End If
                Case #IDCMP_GADGETUP
                    Select GadgetHit
                        Case 1;               Palette is pressed
                            current=EventCode
                            WBox 362,24,427,57,current
                            GTSetAttrs 2,2,#gtsl_level,Red(current)
                            GTSetAttrs 2,3,#gtsl_level,Green(current)
                            GTSetAttrs 2,4,#gtsl_level,Blue(current)

                        Case 2;               Has red been changed
                            RGB current,EventCode,Green(current),Blue(current)

                        Case 3;               Has green been changed
                            RGB current,Red(current),EventCode,Blue(current)

                        Case 4;               Has blue been changed
                            RGB current,Red(current),Green(current),EventCode

                        Case 5;               Loooooooooaaaaaaaad
                            f$=ASLFileRequest$("Load a palette",pa$,fi$)
                            If ReadFile(0,f$)
                                FileInput 0
                                If Lof(0)>12
                                    FileSeek 0,8
                                    filetype$=Inkey$(4)
                                    If filetype$="ILBM"
                                        GTSetString 2,13,"Loading palette..."+SPACE$(10)
                                        LoadPalette 0,f$
                                        Use Palette 0
                                        GTSetString 2,13,blank$
                                    Else
                                        GTSetString 2,13,"Not a CMAP palette file.    "
                                    End If
                                End If
                                DefaultInput
                            End If

                        Case 6;               Saaaaaaaaave
                            f$=ASLFileRequest$("Save palette as",pa$,fi$)
                            If f$
                                ovr=1
                                If Exists(f$)
                                    ovr=EasyRequest("Landscape Request","Do you wish to overwrite"+Chr$(10)+f$," Yes | No ")
                                End If
                                If ovr=1
                                    GTSetString 2,13,"Saving palette..."+SPACE$(10)
                                    SavePalette 0,f$
                                    GTSetString 2,13,blank$
                                End If
                            End If
                        Case 7;               Default
                            For i=0 To (1 LSL newmode\sm_DisplayDepth - 1)
                                rr=dcolours(i)\_Red
                                gg=dcolours(i)\_Green
                                bb=dcolours(i)\_Blue
                                RGB i,rr,gg,bb
                            Next
                            GTSetAttrs 2,2,#gtsl_level,dcolours(current)\_Red
                            GTSetAttrs 2,3,#gtsl_level,dcolours(current)\_Green
                            GTSetAttrs 2,4,#gtsl_level,dcolours(current)\_Blue

                        Case 8;               Spread
                            For i=2 To 12
                                GTDisable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,"Select colour to spread to    "
                            ev.l=WaitEvent
                            While exit=0
                                ev.l=WaitEvent
                                If GadgetHit=1 Then exit=1
                            Wend
                            c2=EventCode
                            exit=0
                            dmax=c2-current
                            cr=(Red(c2)-Red(current))/dmax
                            cg=(Green(c2)-Green(current))/dmax
                            cb=(Blue(c2)-Blue(current))/dmax
                            If c2<>current
                                For i=0 To dmax Step (Sgn(c2-current))
                                    rr=i*cr+Red(current)
                                    gg=i*cg+Green(current)
                                    bb=i*cb+Blue(current)
                                    RGB current+i,rr,gg,bb
                                Next
                            End If
                            For i=2 To 12
                                GTEnable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,blank$

                        Case 9;               copy
                            For i=2 To 12
                                GTDisable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,"Select colour to copy to      "
                            ev.l=WaitEvent
                            While exit=0
                                ev.l=WaitEvent
                                If GadgetHit=1 Then exit=1
                            Wend
                            c2=EventCode
                            exit=0
                            RGB c2,Red(current),Green(current),Blue(current)
                            For i=2 To 12
                                GTEnable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,blank$

                        Case 10;              exchange
                            For i=2 To 12
                                GTDisable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,"Select colour to exchange with to"
                            ev.l=WaitEvent
                            While exit=0
                                ev.l=WaitEvent
                                If GadgetHit=1 Then exit=1
                            Wend
                            c2=EventCode
                            exit=0
                            rr=Red(current)
                            gg=Green(current)
                            bb=Blue(current)
                            RGB current,Red(c2),Green(c2),Blue(c2)
                            RGB c2,rr,gg,bb
                            For i=2 To 12
                                GTEnable 2,i
                                Redraw 2,i
                            Next
                            GTSetString 2,13,blank$

                        Case 11;              OK is selected
                            For i=0 To (1 LSL newmode\sm_DisplayDepth - 1)
                                colours(i)\_Red=Red(i),Green(i),Blue(i)
                            Next
                            exit=1

                        Case 12:exit=1;       Cancel is selected
                    End Select
            End Select
        Wend
        DetachGTList 2
        Free GTList 2
        Free Window 2
        Free Screen 1
    Else
        Use Screen 0
        dummy=EasyRequest("Error","Coukld not open screen, check prefs","OK")
    End If
    Use Screen 0
    Use Window 1
    Activate 1
    exit=0
    Return

.init:
  Select mode\sm_DisplayDepth
    Case 4;                             16 colour palette select
      shades=12
      For i=0 To 15
        rr=colours(i)\_Red
        gg=colours(i)\_Green
        bb=colours(i)\_Blue
        PalRGB 0,i,rr,gg,bb
      Next
    Case 5;                             32 colour palette select
      shades=12
      For i=0 To 31
        rr=colours(i)\_Red
        gg=colours(i)\_Green
        bb=colours(i)\_Blue
        PalRGB 0,i,rr,gg,bb
      Next
  End Select
  Return

Function.w pblue{level}
    ; Select shade of blue

    SHARED mode

    Select mode\sm_DisplayDepth
        Case 4
            Function Return 1
        Case 5
            Function Return (16+level)
    End Select
End Function

Function.w pgreen{level}

; Select shade of green

  SHARED mode

  Select mode\sm_DisplayDepth
    Case 4
      Function Return (3+level)
    Case 5;                             16 or 32 colour mode
      Function Return (3+level)
  End Select

End Function

Statement proc3d{o,SX,SY,SZ}

; *** Graphics drawing routine ***

  SHARED fxgcol,xscale,yscale,zscale,stuff,centrex,centrey

  stuff\x1=stuff\x2
  stuff\x2=stuff\x3
  stuff\y1=stuff\y2
  stuff\y2=stuff\y3
  stuff\x3=centrex-(SX-SY)*xscale
  stuff\y3=centrey+(SX+SY)*yscale-SZ*zscale

  Select o
    Case 5
      Line stuff\x2,stuff\y2,stuff\x3,stuff\y3,fxgcol
    Case 85
      Polyf 3,stuff,fxgcol
  End Select
End Statement

Statement proc3dd{o,xs,ys}

; *** Finger-tip saving statement ***

  SHARED land()

  proc3d{o,xs,ys,land(xs,ys)}
End Statement

.shift:

; *** S(t)imulates the shifting of the land ***

  For longloop.l=1 To faults
    WLocate 5,2
    percent.l=100*longloop/faults
    Print "Faulting "+UStr$(percent)+"% done   "
    If circular Gosub pcircular
    If linear Gosub plinear
    FlushEvents $10
    ev=Event
    If ev=$20
      map=0
      Goto premature
    End If
  Next

  map=1
  osize.w=size
  oxscale.q=xscale
  oyscale.q=yscale
  ozscale.q=zscale
  ocircular=circular
  olinear=linear
  ofaults.l=faults
  odelta.q=delta

  Return

.pcircular:

; *** Circular fault line generator ***

  cx=RRnd(0,size-1)
  cy=RRnd(0,size-1)
  cr=(RRnd(0,size-1))^2
  frnd1.l=RRnd(0,2147483646)
  frnd2.l=RRnd(0,2147483646)
  frnd3.l=frnd2-frnd1
  hadd.q=Sgn(frnd3)
  hadd=hadd*Rnd(1)*delta
  For loopx=0 To size
    dx=(loopx-cx)^2
    If dx<cr
      dy=Sqr(cr-dx)
      y1=cy-dy
      y2=cy+dy
      If y1<0 Then y1=0
      If y2>size+1 Then y2=size+1
      For loopy=y1 To y2
        land(loopx,loopy)=land(loopx,loopy)+hadd
      Next
    End If
  Next
  Return

.plinear

; *** Linear fault line generator ***

  Repeat
    s(0)=RRnd(0,3):s(1)=RRnd(0,3)
  Until s(0)<>s(1)
  Repeat
    For loopj=0 To 1
      Select s(loopj)
        Case 0
          x(loopj)=0
          y(loopj)=RRnd(0,size-1)
        Case 1
          x(loopj)=RRnd(0,size-1)
          y(loopj)=size
        Case 2
          x(loopj)=size
          y(loopj)=RRnd(0,size-1)
        Case 3
          x(loopj)=RRnd(0,size-1)
          y(loopj)=0
      End Select
    Next
  Until x(0)<>x(1) AND y(0)<>y(1)
  m=(y(1)-y(0))/(x(1)-x(0))
  c=y(0)-m*x(0)
  frnd1.l=RRnd(0,2147483646)
  frnd2.l=RRnd(0,2147483646)
  frnd3.l=frnd2-frnd1
  hadd.q=Sgn(frnd3)
  hadd=hadd*Rnd(1)*delta
  For loopx=0 To size
    yy=m*loopx+c
    If yy<0 Then yy=0
    If yy<=size+1
      For loopy=yy To size+1
        land(loopx,loopy)=land(loopx,loopy)+hadd
      Next
    End If
  Next
  Return

.levels:

; *** Calculates height levels ***

  base=0
  peak=0
  aver=0
  For longloopx.l=0 To size-1
    aver=aver+land(longloopx,size)+land(size,longloopx)
    For longloopy.l=0 To size-1
      WLocate 5,2
      percent=100*(longloopx*size+longloopy+1)/(size*size)
      Print "Calculating levels "+UStr$(percent)+"% done "
      FlushEvents $10
      ev=Event
      If ev=$20
        Goto premature
      End If
      aver=aver+land(longloopx,longloopy)
      av=(land(longloopx,longloopy)+land(longloopx+1,longloopy)+land(longloopx,longloopy+1)+land(longloopx+1,longloopy+1))/4
      If av<base Then base=av
      If av>peak Then peak=av
    Next
  Next

  water=aver/(size*size)

  range=(peak-water)/shades
  dept=(water-base)/12
  Return

Statement patch{X,Y}

; *** Calls necessary patch drawing routines ***

  SHARED land(),water,height(),range,dept,fxgcol
  DEFTYPE .b t

  height(0)=land(X,Y)-water
  height(1)=land(X+1,Y)-water
  height(2)=land(X+1,Y+1)-water
  height(3)=land(X,Y+1)-water

  pav.q=0
  For badloop=0 To 3
    pav=pav+height(badloop)
  Next
  pav=pav/4

  col.w=pav/range
  sea.w=pav/dept
  If col<0 Then col=0
  If sea>0 Then sea=0

; *** Draw the sea patch ***

  fxgcol=pblue{sea+13}
  proc3d{4,X,Y,water}
  proc3d{4,X+1,Y,water}
  proc3d{85,X,Y+1,water}
  proc3d{85,X+1,Y+1,water}
  fxgcol=pgreen{col}

; *** Calculate what land patch to draw ***

  total.w=0
  For loopi=0 To 3
    If height(loopi)<0
      total=total+2^loopi
    Else
      total=total+2^(loopi+4)
    End If
  Next

; *** Data for drawing patches ***

  Select total
    Case 240
      proc3dd{4,X,Y}
      proc3dd{4,X+1,Y}
      proc3dd{85,X,Y+1}
      proc3dd{85,X+1,Y+1}
    Case 120
      proc3dd{4,X,Y}
      proc3dd{4,X+1,Y}
      d=height(0)/(height(0)-height(3))
      proc3d{85,X,Y+d,water}
      proc3dd{85,X+1,Y+1}
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
      fxgcol=2
      d=height(0)/(height(0)-height(3))
      proc3d{5,X,Y+d,water}
    Case 180
      proc3dd{4,X,Y}
      proc3dd{4,X,Y+1}
      proc3dd{85,X+1,Y}
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
      d=height(1)/(height(1)-height(2))
      proc3d{85,X+1,Y+d,water}
      fxgcol=2
      d=height(3)/(height(3)-height(2))
      proc3d{5,X+d,Y+1,water}
    Case 60
      proc3dd{4,X,Y}
      proc3dd{4,X+1,Y}
      d=height(0)/(height(0)-height(3))
      proc3d{85,X,Y+d,water}
      d=height(1)/(height(1)-height(2))
      proc3d{85,X+1,Y+d,water}
      fxgcol=2
      d=height(0)/(height(0)-height(3))
      proc3d{5,X,Y+d,water}
    Case 210
      proc3dd{4,X,Y+1}
      proc3dd{4,X+1,Y+1}
      proc3dd{85,X,Y}
      d=height(1)/(height(1)-height(2))
      proc3d{85,X+1,Y+d,water}
      d=height(0)/(height(0)-height(1))
      proc3d{85,X+d,Y,water}
      fxgcol=2
      d=height(1)/(height(1)-height(2))
      proc3d{5,X+1,Y+d,water}
    Case 90
      t=0
      Gosub dangle
      fxgcol=pgreen{col}
      t=2
      Gosub dangle
    Case 150
      proc3dd{4,X,Y}
      proc3dd{4,X,Y+1}
      d=height(0)/(height(0)-height(1))
      proc3d{85,X+d,Y,water}
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
      fxgcol=2
      d=height(0)/(height(0)-height(1))
      proc3d{5,X+d,Y,water}
    Case 30
      t=0
      Gosub dangle
    Case 225
      d=height(0)/(height(0)-height(3))
      proc3d{4,X,Y+d,water}
      d=height(0)/(height(0)-height(1))
      proc3d{4,X+d,Y,water}
      proc3dd{85,X,Y+1}
      proc3dd{85,X+1,Y}
      proc3dd{85,X+1,Y+1}
    Case 105
      proc3dd{4,X+1,Y+1}
      proc3dd{4,X+1,Y}
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
      d=height(0)/(height(0)-height(1))
      proc3d{85,X+d,Y,water}
      fxgcol=2
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
    Case 165
      t=1
      Gosub dangle
      fxgcol=pgreen{col}
      t=3
      Gosub dangle
    Case 45
      t=1
      Gosub dangle
    Case 195
      proc3dd{4,X+1,Y+1}
      proc3dd{4,X,Y+1}
      d=height(1)/(height(1)-height(2))
      proc3d{85,X+1,Y+d,water}
      d=height(0)/(height(0)-height(3))
      proc3d{85,X,Y+d,water}
      fxgcol=2
      d=height(1)/(height(1)-height(2))
      proc3d{5,X+1,Y+d,water}
    Case 75
      t=2
      Gosub dangle
    Case 135
      t=3
      Gosub dangle
  End Select
  Goto endpatch

dangle:

; *** Draw a different bit ***

  Select t
    Case 0
      proc3dd{4,X,Y}
      d=height(0)/(height(0)-height(3))
      proc3d{4,X,Y+d,water}
      d=height(0)/(height(0)-height(1))
      proc3d{85,X+d,Y,water}
      fxgcol=2
      d=height(0)/(height(0)-height(3))
      proc3d{5,X,Y+d,water}
    Case 1
      proc3dd{4,X+1,Y}
      d=height(0)/(height(0)-height(1))
      proc3d{4,X+d,Y,water}
      d=height(1)/(height(1)-height(2))
      proc3d{85,X+1,Y+d,water}
      fxgcol=2
      d=height(0)/(height(0)-height(1))
      proc3d{5,X+d,Y,water}
    Case 2
      proc3dd{4,X+1,Y+1}
      d=height(1)/(height(1)-height(2))
      proc3d{4,X+1,Y+d,water}
      d=height(3)/(height(3)-height(2))
      proc3d{85,X+d,Y+1,water}
      fxgcol=2
      d=height(1)/(height(1)-height(2))
      proc3d{5,X+1,Y+d,water}
    Case 3
      proc3dd{4,X,Y+1}
      d=height(3)/(height(3)-height(2))
      proc3d{4,X+d,Y+1,water}
      d=height(0)/(height(0)-height(3))
      proc3d{85,X,Y+d,water}
      fxgcol=2
      d=height(3)/(height(3)-height(2))
      proc3d{5,X+d,Y+1,water}
  End Select
  Return

endpatch:
End Statement

.draw:

; *** Draw the scene ***
  centrex=mode\sm_DisplayWidth/2
  centrey=mode\sm_DisplayHeight*25/100

  If iff=1 Then Free BitMap 0
  BitMap 0,mode\sm_DisplayWidth,mode\sm_DisplayHeight,mode\sm_DisplayDepth
  Use BitMap 0

  Cls
  For I=0 To size-1
    For J=0 To size-1
      WLocate 5,2
      percent=100*(I*size+J+1)/(size*size)
      Print "Drawing, "+UStr$(percent)+"% done            "
      patch{I,J}
      FlushEvents $10
      ev=Event
      If ev=$20
        iff=0
        Goto premature
      End If

      If I=size-1
        ; *** Draw part of the right side of the landscape ***
        fxgcol=pblue{0}
        proc3d{4,size,J,base}
        proc3d{4,size,J+1,base}
        proc3d{85,size,J,water}
        proc3d{85,size,J+1,water}
        fxgcol=0
        proc3d{5,size,J,water}
        fxgcol=3
        proc3d{4,size,J,base}
        proc3d{4,size,J+1,base}
        proc3dd{85,size,J}
        proc3dd{85,size,J+1}
        fxgcol=0
        proc3dd{5,size,J}
      End If
    Next

; *** Draw the left side of the landscape ***

    fxgcol=pblue{0}
    proc3d{4,I,size,base}
    proc3d{4,I+1,size,base}
    proc3d{85,I,size,water}
    proc3d{85,I+1,size,water}
    fxgcol=0
    proc3d{5,I,size,water}
    fxgcol=3
    proc3d{4,I,size,base}
    proc3d{4,I+1,size,base}
    proc3dd{85,I,size}
    proc3dd{85,I+1,size}
    fxgcol=0
    proc3dd{5,I,size}
  Next
  fxgcol=0
  proc3d{4,size,size,water}
  proc3d{5,size,size,base}
  proc3dd{5,size,size}

  iff=1


  If mode\sm_DisplayID<>0
    Dim SCRtags.TagItem(10)

    SCRtags(0)\ti_Tag=#SA_DisplayID,mode\sm_DisplayID
    SCRtags(1)\ti_Tag=#SA_Depth,mode\sm_DisplayDepth
    SCRtags(2)\ti_Tag=#SA_Width,mode\sm_DisplayWidth
    SCRtags(3)\ti_Tag=#SA_Height,mode\sm_DisplayHeight
    SCRtags(4)\ti_Tag=#SA_AutoScroll,-1
    SCRtags(5)\ti_Tag=#SA_Overscan,#OSCAN_TEXT
    SCRtags(6)\ti_Tag=#SA_Top,0
    SCRtags(7)\ti_Tag=#SA_Left,0
    SCRtags(8)\ti_Tag=#SA_ShowTitle,0
    SCRtags(9)\ti_Tag=#TAG_END

    ScreenTags 1,"",&SCRtags(0)
    *drawscr._Screen = Peek.l(Addr Screen(1))
    If *drawscr
        Use Palette 0
        For i=0 To (1 LSL mode\sm_DisplayDepth - 1)
            RGB i,colours(i)\_Red,colours(i)\_Green,colours(i)\_Blue
        Next
        BltBitMap_ Addr BitMap(0),0,0,*drawscr\_RastPort\_BitMap,0,0,mode\sm_DisplayWidth,mode\sm_DisplayHeight,$C0,-1,0
        ClickMouse
        Free Screen 1
    End If
  End If

  Use Screen 0
  ShowScreen 0

  Activate 0
  Use Window 0
  GTEnable 0,1
  GTDisable 0,2
  GTEnable 0,3
  InnerCls
  For i=1 To 3
    Redraw 0,i
  Next

  Menus On

  Return

.premature
  Use Screen 0
  Use Window 0
  GTEnable 0,1
  GTDisable 0,2
  GTEnable 0,3
  InnerCls
  For i=1 To 3
    Redraw 0,i
  Next
  Menus On
  FlushEvents
  Goto mainloop

.infotext:
Data$ ""
Data$ "   Landscaper by Dave McMinn"
Data$ "   written in BLITZ BASIC ]["
Data$ "   on the 21st September `95"
Data$ ""
Data$ " (and a bit longer after that)"
Data$ ""
Data$ " Feel free to send me some sort"
Data$ "of monetary denomination (wad)."
Data$ "A pound note of crispy fiveness"
Data$ "should suffice, or alternatively"
Data$ "you could send me your firstborn"
Data$ "  to be used as a sacrificial"
Data$ "    offering to the gods..."

.helptext:
Data$ "Faults  = number of land shifting operations"
Data$ "Size    = The size of the landscape (1-160)"
Data$ ""
Data$ "To keep the isometric projection looking correct,"
Data$ "Example screen  Y scale"
Data$ " 320 x 256      0.5  * X scale"
Data$ " 640 x 256      0.25 * X scale"
Data$ " 320 x 512      1    * X scale"
Data$ " 640 x 512      0.5  * X scale"
Data$ ""
Data$ "Z scale is used to exagerate the height"
Data$ "Delta is the most any part of land can change by"
Data$ "in one shift operation."

.colourvalues:
Data.w 0,0,0,1,2,9,15,14,1,0,3,0
Data.w 0,4,0,0,5,0,0,6,0,0,7,0
Data.w 0,8,0,0,9,0,2,10,2,4,11,4
Data.w 6,12,6,9,13,9,13,14,13,15,15,15
Data.w 0,0,4,0,0,5,0,1,6,0,1,7
Data.w 1,2,8,1,2,9,1,3,9,2,4,10
Data.w 2,4,11,2,5,12,3,6,13,3,7,14
Data.w 4,8,15,5,9,15,15,0,0,15,0,15

_screenpens:
Data.w -1





;ASL Screenmode Requester and ScreenTags
;Curt Esser  [e-mail]
;use all or parts in any way you like
;last modified Aug 8, 1998

;NEEDS amigalibs.res, WB 2.01+

WBStartup

WBenchToFront_

NoCli

WbToScreen 1                               ;we use WB for mode requester

LoadFont 0,"topaz.font",8                  ;load test screen's font
*fn=Addr IntuiFont (0)                     ;pointer to screen font

sm$="Select A Screen Mode:"                ;title for mode requester

If NTSC=True                               ;set default screen mode
  imode.l=$19004                           ;NTSC hi-res lace for NTSC
  iheight.w=400
Else
  imode.l=$29004                           ;PAL hi-res laced for PAL
  iheight.w=512
EndIf

Dim SMRtags.TagItem(19)                    ;taglist for mode requester

SMRtags(0)\ti_Tag=#ASLSM_InitialLeftEdge,160     ;these are the position for the
SMRtags(1)\ti_Tag=#ASLSM_InitialTopEdge,10       ;screenmode requester
SMRtags(2)\ti_Tag=#ASLSM_InitialWidth,320
SMRtags(3)\ti_Tag=#ASLSM_InitialHeight,200
SMRtags(4)\ti_Tag=#ASLSM_InitialDisplayID,imode  ;these are shown as "selected"
SMRtags(5)\ti_Tag=#ASLSM_InitialDisplayDepth,3   ;when the requester opens
SMRtags(6)\ti_Tag=#ASLSM_InitialDisplayWidth,640
SMRtags(7)\ti_Tag=#ASLSM_InitialDisplayHeight,iheight
SMRtags(8)\ti_Tag=#ASLSM_InitialOverscanType,1
SMRtags(9)\ti_Tag=#ASLSM_InitialInfoOpened,0     ;no "properties" window
SMRtags(10)\ti_Tag=#ASLSM_DoDepth,1              ;0 for no depth selector
SMRtags(11)\ti_Tag=#ASLSM_DoOverscanType,1       ;0 for no OverScan selector
SMRtags(12)\ti_Tag=#ASLSM_DoWidth,1              ;0 for no width gadget
SMRtags(13)\ti_Tag=#ASLSM_DoHeight,1             ;0 for no height gadget
SMRtags(14)\ti_Tag=#ASLSM_MinHeight,200          ;minimum height allowed
SMRtags(15)\ti_Tag=#ASLSM_MinWidth,320           ;minimum width allowed
SMRtags(16)\ti_Tag=#ASLSM_MinDepth,3             ;minimum depth allowed
SMRtags(17)\ti_Tag=#ASLSM_TitleText,&sm$         ;pointer to requester title$
SMRtags(18)\ti_Tag=#TAG_DONE

;
; ScreenMode requester returns the ScreenMode structure
;

*sreq.ScreenModeRequester=0
*sreq=AllocAslRequest_(2,&SMRtags(0)\ti_Tag)
ok.b=AslRequest_(*sreq,&SMRtags(0)\ti_Tag)

If ok<>0       ;if 0, the cancel gadget was hit

  ;------- read the results into variables
  ;this part is not really necessary, but makes it possible to
  ;just make up the screen without using the requester every time
  ;the program is started
  ;these results could be saved into a "prefs" file
  ;and reloaded into your program before opening the screen

  Display.l=*sreq\sm_DisplayID
  Oscan.w=*sreq\sm_OverscanType
  Dpth.w=*sreq\sm_DisplayDepth
  Widh.l=*sreq\sm_DisplayWidth
  Heit.l=*sreq\sm_DisplayHeight

  ;------- now make the "Program's" screen --------------------
  ; we will make it up in back and pop to the front when ready


  Dim SCRtags.TagItem(12)

  SCRtags(0)\ti_Tag=#SA_DisplayID,Display
  SCRtags(1)\ti_Tag=#SA_Overscan,Oscan
  SCRtags(2)\ti_Tag=#SA_Depth,Dpth
  SCRtags(3)\ti_Tag=#SA_Width,Widh
  SCRtags(4)\ti_Tag=#SA_Height,Heit
  SCRtags(5)\ti_Tag=#SA_Top,0
  SCRtags(6)\ti_Tag=#SA_Left,0
  SCRtags(7)\ti_Tag=#SA_AutoScroll,1         ;autoscroll is on!
  SCRtags(8)\ti_Tag=#SA_Pens,?DriPens        ;List of 13 Dripens
;  SCRtags(9)\ti_Tag=#SA_Behind,1             ;make screen in back of display
  SCRtags(9)\ti_Tag=#SA_ShowTitle,0
  SCRtags(10)\ti_Tag=#TAG_DONE

  d.l=ScreenTags(0,"Test Screen",&SCRtags(0))    ;open the test screen

  Window 1,10,10,300,100,$1000|$8,"Screen info",1,0  ;and a small window
  NPrint d
  NPrint Peek.l(Addr Screen(0))
  NPrint "$"+Hex$(Display)
  NPrint "Depth=",Dpth
  NPrint "Press close gadget to end"

  ShowScreen 0                               ;now bring screen to the front


  Repeat                                     ;just wait until the window
    ev.l=WaitEvent                           ;close gadget is pressed
  Until ev=$200


Else
  Request "","Cancelled!","OK"
  End
EndIf
If (*sreq) Then FreeAslRequest_(*sreq)       ;we MUST free this ourselves


End

Even
DriPens
Dc.w  -1